home *** CD-ROM | disk | FTP | other *** search
/ Nautilus 1992 July / Nautilus-3-8 / Nautilus-3-8.bin / Tools & Utilities / Techy Stuff / Development Environments ƒ / Perl 4.0.2 ƒ / perl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-01-05  |  36.6 KB  |  1,466 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.6 $$Date: 91/11/11 16:38:45 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  * $Log:    perl.c,v $
  9.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  10.  * patch19: default arg for shift was wrong after first subroutine definition
  11.  * patch19: op/regexp.t failed from missing arg to bcmp()
  12.  * 
  13.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  14.  * patch11: random cleanup
  15.  * patch11: $0 was being truncated at times
  16.  * patch11: cppstdin now installed outside of source directory
  17.  * patch11: -P didn't allow use of #elif or #undef
  18.  * patch11: prepared for ctype implementations that don't define isascii()
  19.  * patch11: added eval {}
  20.  * patch11: eval confused by string containing null
  21.  * 
  22.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  23.  * patch10: perl -v printed incorrect copyright notice
  24.  * 
  25.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  26.  * patch4: changed old $^P to $^X
  27.  * 
  28.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  29.  * patch4: new copyright notice
  30.  * patch4: added $^P variable to control calling of perldb routines
  31.  * patch4: added $^F variable to specify maximum system fd, default 2
  32.  * patch4: debugger lost track of lines in eval
  33.  * 
  34.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  35.  * patch1: fixed undefined environ problem
  36.  * 
  37.  * Revision 4.0  91/03/20  01:37:44  lwall
  38.  * 4.0 baseline.
  39.  * 
  40.  */
  41.  
  42. /*SUPPRESS 560*/
  43.  
  44. #include "EXTERN.h"
  45. #include "perl.h"
  46. #include "perly.h"
  47. #ifdef MSDOS
  48. #include "patchlev.h"
  49. #else
  50. #include "patchlevel.h"
  51. #endif
  52.  
  53. char *getenv();
  54.  
  55. #ifdef IAMSUID
  56. #ifndef DOSUID
  57. #define DOSUID
  58. #endif
  59. #endif
  60.  
  61. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  62. #ifdef DOSUID
  63. #undef DOSUID
  64. #endif
  65. #endif
  66.  
  67. static char* moreswitches();
  68. static char* cddir;
  69. static bool minus_c;
  70. static char patchlevel[6];
  71. static char *nrs = "\n";
  72. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  73. static int nrslen = 1;
  74.  
  75. main(argc,argv,env)
  76. register int argc;
  77. register char **argv;
  78. register char **env;
  79. {
  80.     register STR *str;
  81.     register char *s;
  82.     char *scriptname;
  83.     char *getenv();
  84.     bool dosearch = FALSE;
  85. #ifdef DOSUID
  86.     char *validarg = "";
  87. #endif
  88.  
  89. #ifdef macintosh
  90.     extern int StandAlone;
  91.     
  92.     InitToolbox();
  93.     InitCursorCtl(NULL);
  94.     init_env(env);
  95.     env = environ;
  96.  
  97.     if (StandAlone)    {
  98.     char **    newargv;
  99.     char *    prog;
  100.     FSSpec    desc;
  101.     
  102.         GetProgFile(&desc);
  103.     prog = FSp2FullPath(&desc);
  104.     New(777, newargv, 3, char *);
  105.     New(778, newargv[1], strlen(prog)+1, char);
  106.     newargv[0] = argv[0];
  107.     strcpy(newargv[1], prog);
  108.     newargv[2] = 0;
  109.     
  110.     argv = newargv;
  111.     }
  112. #endif
  113.  
  114. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  115. #ifdef IAMSUID
  116. #undef IAMSUID
  117.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  118. setuid perl scripts securely.\n");
  119. #endif
  120. #endif
  121.  
  122.     origargv = argv;
  123.     origargc = argc;
  124.     origenviron = environ;
  125.     uid = (int)getuid();
  126.     euid = (int)geteuid();
  127.     gid = (int)getgid();
  128.     egid = (int)getegid();
  129.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  130. #ifdef MSDOS
  131.     /*
  132.      * There is no way we can refer to them from Perl so close them to save
  133.      * space.  The other alternative would be to provide STDAUX and STDPRN
  134.      * filehandles.
  135.      */
  136.     (void)fclose(stdaux);
  137.     (void)fclose(stdprn);
  138. #endif
  139.     if (do_undump) {
  140.     origfilename = savestr(argv[0]);
  141.     do_undump = 0;
  142.     loop_ptr = -1;        /* start label stack again */
  143.     goto just_doit;
  144.     }
  145.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  146.     linestr = Str_new(65,80);
  147.     str_nset(linestr,"",0);
  148.     str = str_make("",0);        /* first used for -I flags */
  149.     curstash = defstash = hnew(0);
  150.     curstname = str_make("main",4);
  151.     stab_xhash(stabent("_main",TRUE)) = defstash;
  152.     defstash->tbl_name = "main";
  153.     incstab = hadd(aadd(stabent("INC",TRUE)));
  154.     incstab->str_pok |= SP_MULTI;
  155.     for (argc--,argv++; argc > 0; argc--,argv++) {
  156.     if (argv[0][0] != '-' || !argv[0][1])
  157.         break;
  158. #ifdef DOSUID
  159.     if (*validarg)
  160.     validarg = " PHOOEY ";
  161.     else
  162.     validarg = argv[0];
  163. #endif
  164.     s = argv[0]+1;
  165.       reswitch:
  166.     switch (*s) {
  167.     case '0':
  168.     case 'a':
  169.     case 'c':
  170.     case 'd':
  171.     case 'D':
  172.     case 'i':
  173.     case 'l':
  174.     case 'n':
  175.     case 'p':
  176.     case 'u':
  177.     case 'U':
  178.     case 'v':
  179.     case 'w':
  180.         if (s = moreswitches(s))
  181.         goto reswitch;
  182.         break;
  183.  
  184.     case 'e':
  185. #ifdef TAINT
  186.         if (euid != uid || egid != gid)
  187.         fatal("No -e allowed in setuid scripts");
  188. #endif
  189.         if (!e_fp) {
  190.             e_tmpname = savestr(TMPPATH);
  191.         (void)mktemp(e_tmpname);
  192.         e_fp = fopen(e_tmpname,"w");
  193.         if (!e_fp)
  194.             fatal("Cannot open temporary file");
  195.         }
  196.         if (argv[1]) {
  197.         fputs(argv[1],e_fp);
  198.         argc--,argv++;
  199.         }
  200.         (void)putc('\n', e_fp);
  201.         break;
  202.     case 'I':
  203. #ifdef TAINT
  204.         if (euid != uid || egid != gid)
  205.         fatal("No -I allowed in setuid scripts");
  206. #endif
  207.         str_cat(str,"-");
  208.         str_cat(str,s);
  209.         str_cat(str," ");
  210.         if (*++s) {
  211.         (void)apush(stab_array(incstab),str_make(s,0));
  212.         }
  213.         else if (argv[1]) {
  214.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  215.         str_cat(str,argv[1]);
  216.         argc--,argv++;
  217.         str_cat(str," ");
  218.         }
  219.         break;
  220.     case 'P':
  221. #ifdef TAINT
  222.         if (euid != uid || egid != gid)
  223.         fatal("No -P allowed in setuid scripts");
  224. #endif
  225.         preprocess = TRUE;
  226.         s++;
  227.         goto reswitch;
  228.     case 's':
  229. #ifdef TAINT
  230.         if (euid != uid || egid != gid)
  231.         fatal("No -s allowed in setuid scripts");
  232. #endif
  233.         doswitches = TRUE;
  234.         s++;
  235.         goto reswitch;
  236.     case 'S':
  237. #ifdef TAINT
  238.         if (euid != uid || egid != gid)
  239.         fatal("No -S allowed in setuid scripts");
  240. #endif
  241.         dosearch = TRUE;
  242.         s++;
  243.         goto reswitch;
  244.     case 'x':
  245.         doextract = TRUE;
  246.         s++;
  247.         if (*s)
  248.         cddir = savestr(s);
  249.         break;
  250.     case '-':
  251.         argc--,argv++;
  252.         goto switch_end;
  253.     case 0:
  254.         break;
  255.     default:
  256.         fatal("Unrecognized switch: -%s",s);
  257.     }
  258.     }
  259.   switch_end:
  260.     scriptname = argv[0];
  261.     if (e_fp) {
  262.     (void)fclose(e_fp);
  263.     argc++,argv--;
  264.     scriptname = e_tmpname;
  265.     }
  266.  
  267. #ifdef MSDOS
  268. #define PERLLIB_SEP ';'
  269. #else
  270. #ifdef macintosh
  271. #define PERLLIB_SEP ','
  272. #else
  273. #define PERLLIB_SEP ':'
  274. #endif
  275. #endif
  276. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  277.     {
  278.     char * s2 = getenv("PERLLIB");
  279.  
  280.     if ( s2 ) {
  281.         /* Break at all separators */
  282.         while ( *s2 ) {
  283.         /* First, skip any consecutive separators */
  284.         while ( *s2 == PERLLIB_SEP ) {
  285.             /* Uncomment the next line for PATH semantics */
  286.             /* (void)apush(stab_array(incstab),str_make(".",1)); */
  287.             s2++;
  288.         }
  289.         if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
  290.             (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
  291.             s2 = s+1;
  292.         } else {
  293.             (void)apush(stab_array(incstab),str_make(s2,0));
  294.             break;
  295.         }
  296.         }
  297.     }
  298.     }
  299. #endif /* TAINT */
  300.  
  301. #ifdef macintosh
  302. #ifdef PRIVLIB
  303.     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  304. #endif
  305.     (void)apush(stab_array(incstab),str_make(":",1));
  306. #else
  307. #ifndef PRIVLIB
  308. #define PRIVLIB "/usr/local/lib/perl"
  309. #endif
  310.     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  311.     (void)apush(stab_array(incstab),str_make(".",1));
  312. #endif
  313.  
  314.     str_set(&str_no,No);
  315.     str_set(&str_yes,Yes);
  316.  
  317.     /* open script */
  318.  
  319.     if (scriptname == Nullch)
  320. #ifdef MSDOS
  321.     {
  322.     if ( isatty(fileno(stdin)) )
  323.       moreswitches("v");
  324.     scriptname = "-";
  325.     }
  326. #else
  327. #ifdef macintosh
  328.     scriptname = "Dev:Stdin";
  329. #else
  330.     scriptname = "-";
  331. #endif
  332. #endif
  333.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  334.     char *xfound = Nullch, *xfailed = Nullch;
  335.     int len;
  336.  
  337.     bufend = s + strlen(s);
  338.     while (*s) {
  339. #ifndef MSDOS
  340. #ifndef macintosh
  341.         s = cpytill(tokenbuf,s,bufend,':',&len);
  342. #else
  343.         for (len = 0; *s && *s != ','; tokenbuf[len++] = *s++);
  344.         tokenbuf[len] = '\0';
  345. #endif
  346. #else
  347.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  348.         tokenbuf[len] = '\0';
  349. #endif
  350.         if (*s)
  351.         s++;
  352. #ifndef MSDOS
  353. #ifdef macintosh
  354.         if (len && tokenbuf[len-1] != ':')
  355. #else
  356.         if (len && tokenbuf[len-1] != '/')
  357. #endif
  358. #else
  359.         if (len && tokenbuf[len-1] != '\\')
  360. #endif
  361.         (void)strcat(tokenbuf+len,"/");
  362.         (void)strcat(tokenbuf+len,scriptname);
  363. #ifdef DEBUGGING
  364.         if (debug & 1)
  365.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  366. #endif
  367.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  368.         continue;
  369.         if (S_ISREG(statbuf.st_mode)
  370.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  371.         xfound = tokenbuf;              /* bingo! */
  372.         break;
  373.         }
  374.         if (!xfailed)
  375.         xfailed = savestr(tokenbuf);
  376.     }
  377.     if (!xfound)
  378.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  379.     if (xfailed)
  380.         Safefree(xfailed);
  381.     scriptname = savestr(xfound);
  382.     }
  383.  
  384.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  385.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  386.  
  387.     origfilename = savestr(scriptname);
  388.     curcmd->c_filestab = fstab(origfilename);
  389.     if (strEQ(origfilename,"-"))
  390.     argv[0] = "";
  391.     if (preprocess) {
  392. #ifndef macintosh
  393.     char *cpp = CPPSTDIN;
  394.  
  395.     if (strEQ(cpp,"cppstdin"))
  396.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  397.     else
  398.         sprintf(tokenbuf, "%s", cpp);
  399. #endif
  400. #ifdef PRIVLIB
  401.     str_cat(str,"-I");
  402.     str_cat(str,PRIVLIB);
  403. #endif
  404. #ifdef macintosh
  405.     (void)sprintf(buf, 
  406. "StreamEdit %s -e '/Ñ[┬#]/     Next' "
  407. " -e '/ìÑ#[ ╢t]*include[ ╢t]/     Next' "
  408. " -e '/ìÑ#[ ╢t]*define[ ╢t]/     Next' "
  409. " -e '/ìÑ#[ ╢t]*if[ ╢t]/     Next' "
  410. " -e '/ìÑ#[ ╢t]*ifdef[ ╢t]/     Next' "
  411. " -e '/ìÑ#[ ╢t]*ifndef[ ╢t]/     Next' "
  412. " -e '/ìÑ#[ ╢t]*else/         Next' "
  413. " -e '/ìÑ#[ ╢t]*elif/         Next' "
  414. " -e '/ìÑ#[ ╢t]*undef/         Next' "
  415. " -e '/ìÑ#[ ╢t]*endif/         Next' "
  416. " -e '/ìÑ[ ╢t]*#┼/        Delete' "
  417. " %s | C -e %s",
  418.       (doextract ? "-e '1,/^#/d\n'" : ""),
  419.       scriptname, str_get(str));
  420. #else
  421.     (void)sprintf(buf, "\
  422. %ssed %s -e '/^[^#]/b' \
  423.  -e '/^#[     ]*include[     ]/b' \
  424.  -e '/^#[     ]*define[     ]/b' \
  425.  -e '/^#[     ]*if[     ]/b' \
  426.  -e '/^#[     ]*ifdef[     ]/b' \
  427.  -e '/^#[     ]*ifndef[     ]/b' \
  428.  -e '/^#[     ]*else/b' \
  429.  -e '/^#[     ]*elif[     ]/b' \
  430.  -e '/^#[     ]*undef[     ]/b' \
  431.  -e '/^#[     ]*endif/b' \
  432.  -e 's/^[     ]*#.*//' \
  433.  %s | %s -C %s %s",
  434. #ifdef MSDOS
  435.       "",
  436. #else
  437.       "/bin/",
  438. #endif
  439.       (doextract ? "-e '1,/^#/d\n'" : ""),
  440.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  441. #endif
  442.         fputs(buf,stderr);
  443.         fputs("\n",stderr);
  444. #ifdef DEBUGGING
  445.     if (debug & 64) {
  446.         fputs(buf,stderr);
  447.         fputs("\n",stderr);
  448.     }
  449. #endif
  450.     doextract = FALSE;
  451. #ifdef IAMSUID                /* actually, this is caught earlier */
  452.     if (euid != uid && !euid)    /* if running suidperl */
  453. #ifdef HAS_SETEUID
  454.         (void)seteuid(uid);        /* musn't stay setuid root */
  455. #else
  456. #ifdef HAS_SETREUID
  457.         (void)setreuid(-1, uid);
  458. #else
  459.         setuid(uid);
  460. #endif
  461. #endif
  462. #endif /* IAMSUID */
  463.     rsfp = mypopen(buf,"r");
  464.     }
  465.     else if (!*scriptname) {
  466. #ifdef TAINT
  467.     if (euid != uid || egid != gid)
  468.         fatal("Can't take set-id script from stdin");
  469. #endif
  470.     rsfp = stdin;
  471.     }
  472.     else
  473.     rsfp = fopen(scriptname,"r");
  474.     if ((FILE*)rsfp == Nullfp) {
  475. #ifdef DOSUID
  476. #ifndef IAMSUID        /* in case script is not readable before setuid */
  477.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  478.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  479.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  480.         execv(buf, origargv);    /* try again */
  481.         fatal("Can't do setuid\n");
  482.     }
  483. #endif
  484. #endif
  485.     fatal("Can't open perl script \"%s\": %s\n",
  486.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  487.     }
  488.     str_free(str);        /* free -I directories */
  489.     str = Nullstr;
  490.  
  491.     /* do we need to emulate setuid on scripts? */
  492.  
  493.     /* This code is for those BSD systems that have setuid #! scripts disabled
  494.      * in the kernel because of a security problem.  Merely defining DOSUID
  495.      * in perl will not fix that problem, but if you have disabled setuid
  496.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  497.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  498.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  499.      * discovers that it has opened a setuid script, it calls suidperl with
  500.      * the same argv that it had.  If suidperl finds that the script it has
  501.      * just opened is NOT setuid root, it sets the effective uid back to the
  502.      * uid.  We don't just make perl setuid root because that loses the
  503.      * effective uid we had before invoking perl, if it was different from the
  504.      * uid.
  505.      *
  506.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  507.      * be defined in suidperl only.  suidperl must be setuid root.  The
  508.      * Configure script will set this up for you if you want it.
  509.      *
  510.      * There is also the possibility of have a script which is running
  511.      * set-id due to a C wrapper.  We want to do the TAINT checks
  512.      * on these set-id scripts, but don't want to have the overhead of
  513.      * them in normal perl, and can't use suidperl because it will lose
  514.      * the effective uid info, so we have an additional non-setuid root
  515.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  516.      */
  517.  
  518. #ifdef DOSUID
  519.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  520.     fatal("Can't stat script \"%s\"",origfilename);
  521.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  522.     int len;
  523.  
  524. #ifdef IAMSUID
  525. #ifndef HAS_SETREUID
  526.     /* On this access check to make sure the directories are readable,
  527.      * there is actually a small window that the user could use to make
  528.      * filename point to an accessible directory.  So there is a faint
  529.      * chance that someone could execute a setuid script down in a
  530.      * non-accessible directory.  I don't know what to do about that.
  531.      * But I don't think it's too important.  The manual lies when
  532.      * it says access() is useful in setuid programs.
  533.      */
  534.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  535.         fatal("Permission denied");
  536. #else
  537.     /* If we can swap euid and uid, then we can determine access rights
  538.      * with a simple stat of the file, and then compare device and
  539.      * inode to make sure we did stat() on the same file we opened.
  540.      * Then we just have to make sure he or she can execute it.
  541.      */
  542.     {
  543.         struct stat tmpstatbuf;
  544.  
  545.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  546.         fatal("Can't swap uid and euid");    /* really paranoid */
  547.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  548.         fatal("Permission denied");    /* testing full pathname here */
  549.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  550.         tmpstatbuf.st_ino != statbuf.st_ino) {
  551.         (void)fclose(rsfp);
  552.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  553.             fprintf(rsfp,
  554. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  555. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  556.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  557.             statbuf.st_dev, statbuf.st_ino,
  558.             stab_val(curcmd->c_filestab)->str_ptr,
  559.             statbuf.st_uid, statbuf.st_gid);
  560.             (void)mypclose(rsfp);
  561.         }
  562.         fatal("Permission denied\n");
  563.         }
  564.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  565.         fatal("Can't reswap uid and euid");
  566.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  567.         fatal("Permission denied\n");
  568.     }
  569. #endif /* HAS_SETREUID */
  570. #endif /* IAMSUID */
  571.  
  572.     if (!S_ISREG(statbuf.st_mode))
  573.         fatal("Permission denied");
  574.     if (statbuf.st_mode & S_IWOTH)
  575.         fatal("Setuid/gid script is writable by world");
  576.     doswitches = FALSE;        /* -s is insecure in suid */
  577.     curcmd->c_line++;
  578.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  579.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  580.         fatal("No #! line");
  581.     s = tokenbuf+2;
  582.     if (*s == ' ') s++;
  583.     while (!isSPACE(*s)) s++;
  584.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  585.         fatal("Not a perl script");
  586.     while (*s == ' ' || *s == '\t') s++;
  587.     /*
  588.      * #! arg must be what we saw above.  They can invoke it by
  589.      * mentioning suidperl explicitly, but they may not add any strange
  590.      * arguments beyond what #! says if they do invoke suidperl that way.
  591.      */
  592.     len = strlen(validarg);
  593.     if (strEQ(validarg," PHOOEY ") ||
  594.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  595.         fatal("Args must match #! line");
  596.  
  597. #ifndef IAMSUID
  598.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  599.         euid == statbuf.st_uid)
  600.         if (!do_undump)
  601.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  602. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  603. #endif /* IAMSUID */
  604.  
  605.     if (euid) {    /* oops, we're not the setuid root perl */
  606.         (void)fclose(rsfp);
  607. #ifndef IAMSUID
  608.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  609.         execv(buf, origargv);    /* try again */
  610. #endif
  611.         fatal("Can't do setuid\n");
  612.     }
  613.  
  614.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
  615. #ifdef HAS_SETEGID
  616.         (void)setegid(statbuf.st_gid);
  617. #else
  618. #ifdef HAS_SETREGID
  619.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  620. #else
  621.         setgid(statbuf.st_gid);
  622. #endif
  623. #endif
  624.     if (statbuf.st_mode & S_ISUID) {
  625.         if (statbuf.st_uid != euid)
  626. #ifdef HAS_SETEUID
  627.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  628. #else
  629. #ifdef HAS_SETREUID
  630.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  631. #else
  632.         setuid(statbuf.st_uid);
  633. #endif
  634. #endif
  635.     }
  636.     else if (uid)            /* oops, mustn't run as root */
  637. #ifdef HAS_SETEUID
  638.         (void)seteuid((UIDTYPE)uid);
  639. #else
  640. #ifdef HAS_SETREUID
  641.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  642. #else
  643.         setuid((UIDTYPE)uid);
  644. #endif
  645. #endif
  646.     uid = (int)getuid();
  647.     euid = (int)geteuid();
  648.     gid = (int)getgid();
  649.     egid = (int)getegid();
  650.     if (!cando(S_IXUSR,TRUE,&statbuf))
  651.         fatal("Permission denied\n");    /* they can't do this */
  652.     }
  653. #ifdef IAMSUID
  654.     else if (preprocess)
  655.     fatal("-P not allowed for setuid/setgid script\n");
  656.     else
  657.     fatal("Script is not setuid/setgid in suidperl\n");
  658. #else
  659. #ifndef TAINT        /* we aren't taintperl or suidperl */
  660.     /* script has a wrapper--can't run suidperl or we lose euid */
  661.     else if (euid != uid || egid != gid) {
  662.     (void)fclose(rsfp);
  663.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  664.     execv(buf, origargv);    /* try again */
  665.     fatal("Can't run setuid script with taint checks");
  666.     }
  667. #endif /* TAINT */
  668. #endif /* IAMSUID */
  669. #else /* !DOSUID */
  670. #ifndef TAINT        /* we aren't taintperl or suidperl */
  671.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  672. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  673.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  674.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  675.         ||
  676.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  677.        )
  678.         if (!do_undump)
  679.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  680. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  681. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  682.     /* not set-id, must be wrapped */
  683.     (void)fclose(rsfp);
  684.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  685.     execv(buf, origargv);    /* try again */
  686.     fatal("Can't run setuid script with taint checks");
  687.     }
  688. #endif /* TAINT */
  689. #endif /* DOSUID */
  690.  
  691. #if !defined(IAMSUID) && !defined(TAINT)
  692.  
  693.     /* skip forward in input to the real script? */
  694.  
  695.     while (doextract) {
  696.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  697.         fatal("No Perl script found in input\n");
  698.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  699.         ungetc('\n',rsfp);        /* to keep line count right */
  700.         doextract = FALSE;
  701.         if (s = instr(s,"perl -")) {
  702.         s += 6;
  703.         /*SUPPRESS 530*/
  704.         while (s = moreswitches(s)) ;
  705.         }
  706.         if (cddir && chdir(cddir) < 0)
  707.         fatal("Can't chdir to %s",cddir);
  708.     }
  709.     }
  710. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  711.  
  712.     defstab = stabent("_",TRUE);
  713.  
  714.     subname = str_make("main",4);
  715.     if (perldb) {
  716.     debstash = hnew(0);
  717.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  718.     curstash = debstash;
  719.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  720.     tmpstab->str_pok |= SP_MULTI;
  721.     dbargs->ary_flags = 0;
  722.     DBstab = stabent("DB",TRUE);
  723.     DBstab->str_pok |= SP_MULTI;
  724.     DBline = stabent("dbline",TRUE);
  725.     DBline->str_pok |= SP_MULTI;
  726.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  727.     tmpstab->str_pok |= SP_MULTI;
  728.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  729.     tmpstab->str_pok |= SP_MULTI;
  730.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  731.     tmpstab->str_pok |= SP_MULTI;
  732.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  733.     tmpstab->str_pok |= SP_MULTI;
  734.     curstash = defstash;
  735.     }
  736.  
  737.     /* init tokener */
  738.  
  739.     bufend = bufptr = str_get(linestr);
  740.  
  741.     savestack = anew(Nullstab);        /* for saving non-local values */
  742.     stack = anew(Nullstab);        /* for saving non-local values */
  743.     stack->ary_flags = 0;        /* not a real array */
  744.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  745.     afill(savestack,63); afill(savestack,-1);
  746.  
  747.     /* now parse the script */
  748.  
  749.     error_count = 0;
  750.     if (yyparse() || error_count) {
  751.     if (minus_c)
  752.         fatal("%s had compilation errors.\n", origfilename);
  753.     else {
  754.         fatal("Execution of %s aborted due to compilation errors.\n",
  755.         origfilename);
  756.     }
  757.     }
  758.  
  759.     New(50,loop_stack,128,struct loop);
  760. #ifdef DEBUGGING
  761.     if (debug) {
  762.     New(51,debname,128,char);
  763.     New(52,debdelim,128,char);
  764.     }
  765. #endif
  766.     curstash = defstash;
  767.  
  768.     preprocess = FALSE;
  769.     if (e_fp) {
  770.     e_fp = Nullfp;
  771.     (void)UNLINK(e_tmpname);
  772.     }
  773.  
  774.     /* initialize everything that won't change if we undump */
  775.  
  776.     if (sigstab = stabent("SIG",allstabs)) {
  777.     sigstab->str_pok |= SP_MULTI;
  778.     (void)hadd(sigstab);
  779.     }
  780.  
  781.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  782. #ifdef macintosh
  783.     init_macintosh();
  784. #endif
  785.     userinit();        /* in case linked C routines want magical variables */
  786.  
  787.     amperstab = stabent("&",allstabs);
  788.     leftstab = stabent("`",allstabs);
  789.     rightstab = stabent("'",allstabs);
  790.     sawampersand = (amperstab || leftstab || rightstab);
  791.     if (tmpstab = stabent(":",allstabs))
  792.     str_set(STAB_STR(tmpstab),chopset);
  793.     if (tmpstab = stabent("\024",allstabs))
  794.     time(&basetime);
  795.  
  796.     /* these aren't necessarily magical */
  797.     if (tmpstab = stabent(";",allstabs))
  798.     str_set(STAB_STR(tmpstab),"\034");
  799.     if (tmpstab = stabent("]",allstabs)) {
  800.     str = STAB_STR(tmpstab);
  801.     str_set(str,rcsid);
  802.     str->str_u.str_nval = atof(patchlevel);
  803.     str->str_nok = 1;
  804.     }
  805.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  806.  
  807.     stdinstab = stabent("STDIN",TRUE);
  808.     stdinstab->str_pok |= SP_MULTI;
  809.     stab_io(stdinstab) = stio_new();
  810.     stab_io(stdinstab)->ifp = stdin;
  811.     tmpstab = stabent("stdin",TRUE);
  812.     stab_io(tmpstab) = stab_io(stdinstab);
  813.     tmpstab->str_pok |= SP_MULTI;
  814.  
  815.     tmpstab = stabent("STDOUT",TRUE);
  816.     tmpstab->str_pok |= SP_MULTI;
  817.     stab_io(tmpstab) = stio_new();
  818.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  819.     defoutstab = tmpstab;
  820.     tmpstab = stabent("stdout",TRUE);
  821.     stab_io(tmpstab) = stab_io(defoutstab);
  822.     tmpstab->str_pok |= SP_MULTI;
  823.  
  824.     curoutstab = stabent("STDERR",TRUE);
  825.     curoutstab->str_pok |= SP_MULTI;
  826.     stab_io(curoutstab) = stio_new();
  827.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  828.     tmpstab = stabent("stderr",TRUE);
  829.     stab_io(tmpstab) = stab_io(curoutstab);
  830.     tmpstab->str_pok |= SP_MULTI;
  831.     curoutstab = defoutstab;        /* switch back to STDOUT */
  832.  
  833.     statname = Str_new(66,0);        /* last filename we did stat on */
  834.  
  835.     /* now that script is parsed, we can modify record separator */
  836.  
  837.     rs = nrs;
  838.     rslen = nrslen;
  839.     rschar = nrschar;
  840.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  841.  
  842.     if (do_undump)
  843.     my_unexec();
  844.  
  845.   just_doit:        /* come here if running an undumped a.out */
  846.     argc--,argv++;    /* skip name of script */
  847.     if (doswitches) {
  848.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  849.         if (argv[0][1] == '-') {
  850.         argc--,argv++;
  851.         break;
  852.         }
  853.         if (s = index(argv[0], '=')) {
  854.         *s++ = '\0';
  855.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  856.         }
  857.         else
  858.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  859.     }
  860.     }
  861. #ifdef TAINT
  862.     tainted = 1;
  863. #endif
  864.     if (tmpstab = stabent("0",allstabs)) {
  865.     str_set(stab_val(tmpstab),origfilename);
  866.     magicname("0", Nullch, 0);
  867.     }
  868.     if (tmpstab = stabent("\030",allstabs))
  869.     str_set(stab_val(tmpstab),origargv[0]);
  870.     if (argvstab = stabent("ARGV",allstabs)) {
  871.     argvstab->str_pok |= SP_MULTI;
  872.     (void)aadd(argvstab);
  873.     aclear(stab_array(argvstab));
  874.     for (; argc > 0; argc--,argv++) {
  875.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  876.     }
  877.     }
  878. #ifdef TAINT
  879.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  880. #endif
  881.     if (envstab = stabent("ENV",allstabs)) {
  882.     envstab->str_pok |= SP_MULTI;
  883.     (void)hadd(envstab);
  884.     hclear(stab_hash(envstab), FALSE);
  885.     if (env != environ)
  886.         environ[0] = Nullch;
  887.     for (; *env; env++) {
  888.         if (!(s = index(*env,'=')))
  889.         continue;
  890.         *s++ = '\0';
  891.         str = str_make(s--,0);
  892.         str_magic(str, envstab, 'E', *env, s - *env);
  893.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  894.         *s = '=';
  895.     }
  896.     }
  897. #ifdef TAINT
  898.     tainted = 0;
  899. #endif
  900.     if (tmpstab = stabent("$",allstabs))
  901.     str_numset(STAB_STR(tmpstab),(double)getpid());
  902.  
  903.     if (dowarn) {
  904.     stab_check('A','Z');
  905.     stab_check('a','z');
  906.     }
  907.  
  908.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  909.     loop_ptr = -1;        /* start label stack again */
  910.  
  911. #ifdef DEBUGGING
  912.     if (debug & 1024)
  913.     dump_all();
  914.     if (debug)
  915.     fprintf(stderr,"\nEXECUTING...\n\n");
  916. #endif
  917.  
  918.     if (minus_c) {
  919.     fprintf(stderr,"%s syntax OK\n", origfilename);
  920.     exit(0);
  921.     }
  922.  
  923.     /* do it */
  924.  
  925.     (void) cmd_exec(main_root,G_SCALAR,-1);
  926.  
  927.     if (goto_targ)
  928.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  929.     exit(0);
  930.     /* NOTREACHED */
  931. }
  932.  
  933. void
  934. magicalize(list)
  935. register char *list;
  936. {
  937.     char sym[2];
  938.  
  939.     sym[1] = '\0';
  940.     while (*sym = *list++)
  941.     magicname(sym, Nullch, 0);
  942. }
  943.  
  944. void
  945. magicname(sym,name,namlen)
  946. char *sym;
  947. char *name;
  948. int namlen;
  949. {
  950.     register STAB *stab;
  951.  
  952.     if (stab = stabent(sym,allstabs)) {
  953.     stab_flags(stab) = SF_VMAGIC;
  954.     str_magic(stab_val(stab), stab, 0, name, namlen);
  955.     }
  956. }
  957.  
  958. void
  959. savelines(array, str)
  960. ARRAY *array;
  961. STR *str;
  962. {
  963.     register char *s = str->str_ptr;
  964.     register char *send = str->str_ptr + str->str_cur;
  965.     register char *t;
  966.     register int line = 1;
  967.  
  968.     while (s && s < send) {
  969.     STR *tmpstr = Str_new(85,0);
  970.  
  971.     t = index(s, '\n');
  972.     if (t)
  973.         t++;
  974.     else
  975.         t = send;
  976.  
  977.     str_nset(tmpstr, s, t - s);
  978.     astore(array, line++, tmpstr);
  979.     s = t;
  980.     }
  981. }
  982.  
  983. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  984.  
  985. int
  986. do_eval(str,optype,stash,savecmd,gimme,arglast)
  987. STR *str;
  988. int optype;
  989. HASH *stash;
  990. int savecmd;
  991. int gimme;
  992. int *arglast;
  993. {
  994.     STR **st = stack->ary_array;
  995.     int retval;
  996.     CMD *myroot = Nullcmd;
  997.     ARRAY *ar;
  998.     int i;
  999.     CMD * VOLATILE oldcurcmd = curcmd;
  1000.     VOLATILE int oldtmps_base = tmps_base;
  1001.     VOLATILE int oldsave = savestack->ary_fill;
  1002.     VOLATILE int oldperldb = perldb;
  1003.     SPAT * VOLATILE oldspat = curspat;
  1004.     SPAT * VOLATILE oldlspat = lastspat;
  1005.     static char *last_eval = Nullch;
  1006.     static long last_elen = 0;
  1007.     static CMD *last_root = Nullcmd;
  1008.     VOLATILE int sp = arglast[0];
  1009.     char *specfilename;
  1010.     char *tmpfilename;
  1011.     int parsing = 1;
  1012.  
  1013.     tmps_base = tmps_max;
  1014.     if (curstash != stash) {
  1015. #ifndef macintosh
  1016.     (void)savehptr(&curstash);
  1017. #else
  1018.     savehptr(&curstash);
  1019. #endif
  1020.     curstash = stash;
  1021.     }
  1022.     str_set(stab_val(stabent("@",TRUE)),"");
  1023.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1024.     perldb = FALSE;
  1025.     curcmd = &compiling;
  1026.     if (optype == O_EVAL) {        /* normal eval */
  1027.     curcmd->c_filestab = fstab("(eval)");
  1028.     curcmd->c_line = 1;
  1029.     str_sset(linestr,str);
  1030.     str_cat(linestr,";\n");        /* be kind to them */
  1031.     if (perldb)
  1032.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1033.     }
  1034.     else {
  1035.     if (last_root && !in_eval) {
  1036.         Safefree(last_eval);
  1037.         last_eval = Nullch;
  1038.         cmd_free(last_root);
  1039.         last_root = Nullcmd;
  1040.     }
  1041.     specfilename = str_get(str);
  1042.     str_set(linestr,"");
  1043.     if (optype == O_REQUIRE && &str_undef !=
  1044.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1045.         curcmd = oldcurcmd;
  1046.         tmps_base = oldtmps_base;
  1047.         st[++sp] = &str_yes;
  1048.         perldb = oldperldb;
  1049.         return sp;
  1050.     }
  1051.     tmpfilename = savestr(specfilename);
  1052. #ifdef macintosh
  1053.     if ((strchr(tmpfilename, ':') != NULL) && *tmpfilename != ':')
  1054. #else
  1055.     if (index("/.", *tmpfilename))
  1056. #endif
  1057.         rsfp = fopen(tmpfilename,"r");
  1058.     else {
  1059.         ar = stab_array(incstab);
  1060.         for (i = 0; i <= ar->ary_fill; i++) {
  1061. #ifdef macintosh
  1062.         char *macptr = str_get(afetch(ar,i,TRUE));
  1063.         int   colon1 = macptr[strlen(macptr)-1] == ':';
  1064.         int   colon2 = *specfilename == ':';
  1065.         
  1066.         if (colon1 && colon2)
  1067.             (void) sprintf(buf, "%s%s", macptr, specfilename+1);
  1068.         else if (colon1 || colon2 )
  1069.             (void) sprintf(buf, "%s%s", macptr, specfilename);
  1070.         else 
  1071.             (void) sprintf(buf, "%s:%s", macptr, specfilename);
  1072. #else
  1073.         (void)sprintf(buf, "%s/%s",
  1074.           str_get(afetch(ar,i,TRUE)), specfilename);
  1075. #endif
  1076.         rsfp = fopen(buf,"r");
  1077.         if (rsfp) {
  1078.             char *s = buf;
  1079.  
  1080. #ifndef macintosh
  1081.             if (*s == '.' && s[1] == '/')
  1082.             s += 2;
  1083. #endif
  1084.             Safefree(tmpfilename);
  1085.             tmpfilename = savestr(s);
  1086.             break;
  1087.         }
  1088.         }
  1089.     }
  1090.     curcmd->c_filestab = fstab(tmpfilename);
  1091.     Safefree(tmpfilename);
  1092.     tmpfilename = Nullch;
  1093.     if (!rsfp) {
  1094.         curcmd = oldcurcmd;
  1095.         tmps_base = oldtmps_base;
  1096.         if (optype == O_REQUIRE) {
  1097.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1098.         if (instr(tokenbuf,".h "))
  1099.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1100.         if (instr(tokenbuf,".ph "))
  1101.             strcat(tokenbuf," (did you run h2ph?)");
  1102.         fatal("%s",tokenbuf);
  1103.         }
  1104.         if (gimme != G_ARRAY)
  1105.         st[++sp] = &str_undef;
  1106.         perldb = oldperldb;
  1107.         return sp;
  1108.     }
  1109.     curcmd->c_line = 0;
  1110.     }
  1111.     in_eval++;
  1112.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1113.     bufend = bufptr + linestr->str_cur;
  1114.     if (++loop_ptr >= loop_max) {
  1115.     loop_max += 128;
  1116.     Renew(loop_stack, loop_max, struct loop);
  1117.     }
  1118.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1119.     loop_stack[loop_ptr].loop_sp = sp;
  1120. #ifdef DEBUGGING
  1121.     if (debug & 4) {
  1122.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1123.     }
  1124. #endif
  1125.     eval_root = Nullcmd;
  1126.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1127.     retval = 1;
  1128.     }
  1129.     else {
  1130.     error_count = 0;
  1131.     if (rsfp) {
  1132.         retval = yyparse();
  1133.         retval |= error_count;
  1134.     }
  1135.     else if (last_root && last_elen == bufend - bufptr
  1136.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1137.         retval = 0;
  1138.         eval_root = last_root;    /* no point in reparsing */
  1139.     }
  1140.     else if (in_eval == 1 && !savecmd) {
  1141.         if (last_root) {
  1142.         Safefree(last_eval);
  1143.         last_eval = Nullch;
  1144.         cmd_free(last_root);
  1145.         }
  1146.         last_root = Nullcmd;
  1147.         last_elen = bufend - bufptr;
  1148.         last_eval = nsavestr(bufptr, last_elen);
  1149.         retval = yyparse();
  1150.         retval |= error_count;
  1151.         if (!retval)
  1152.         last_root = eval_root;
  1153.         if (!last_root) {
  1154.         Safefree(last_eval);
  1155.         last_eval = Nullch;
  1156.         }
  1157.     }
  1158.     else
  1159.         retval = yyparse();
  1160.     }
  1161.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1162.  
  1163.     if (retval) {
  1164.     st = stack->ary_array;
  1165.     sp = arglast[0];
  1166.     if (gimme != G_ARRAY)
  1167.         st[++sp] = &str_undef;
  1168.     if (parsing) {
  1169. #ifndef MANGLEDPARSE
  1170. #ifdef DEBUGGING
  1171.         if (debug & 128)
  1172.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1173. #endif
  1174.         cmd_free(eval_root);
  1175. #endif
  1176.         if ((CMD*)eval_root == last_root)
  1177.         last_root = Nullcmd;
  1178.         eval_root = myroot = Nullcmd;
  1179.     }
  1180.     if (rsfp) {
  1181.         fclose(rsfp);
  1182.         rsfp = 0;
  1183.     }
  1184.     }
  1185.     else {
  1186.     parsing = 0;
  1187.     sp = cmd_exec(eval_root,gimme,sp);
  1188.     st = stack->ary_array;
  1189.     for (i = arglast[0] + 1; i <= sp; i++)
  1190.         st[i] = str_mortal(st[i]);
  1191.                 /* if we don't save result, free zaps it */
  1192.     if (savecmd)
  1193.         eval_root = myroot;
  1194.     else if (in_eval != 1 && myroot != last_root)
  1195.         cmd_free(myroot);
  1196.     }
  1197.  
  1198.     perldb = oldperldb;
  1199.     in_eval--;
  1200. #ifdef DEBUGGING
  1201.     if (debug & 4) {
  1202.     char *tmps = loop_stack[loop_ptr].loop_label;
  1203.     deb("(Popping label #%d %s)\n",loop_ptr,
  1204.         tmps ? tmps : "" );
  1205.     }
  1206. #endif
  1207.     loop_ptr--;
  1208.     tmps_base = oldtmps_base;
  1209.     curspat = oldspat;
  1210.     lastspat = oldlspat;
  1211.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1212.     restorelist(oldsave);
  1213.  
  1214.     if (optype != O_EVAL) {
  1215.     if (retval) {
  1216.         if (optype == O_REQUIRE)
  1217.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1218.     }
  1219.     else {
  1220.         curcmd = oldcurcmd;
  1221.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1222.         (void)hstore(stab_hash(incstab), specfilename,
  1223.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1224.               0 );
  1225.         }
  1226.         else if (optype == O_REQUIRE)
  1227.         fatal("%s did not return a true value", specfilename);
  1228.     }
  1229.     }
  1230.     curcmd = oldcurcmd;
  1231.     return sp;
  1232. }
  1233.  
  1234. int
  1235. do_try(cmd,gimme,arglast)
  1236. CMD *cmd;
  1237. int gimme;
  1238. int *arglast;
  1239. {
  1240.     STR **st = stack->ary_array;
  1241.  
  1242.     CMD * VOLATILE oldcurcmd = curcmd;
  1243.     VOLATILE int oldtmps_base = tmps_base;
  1244.     VOLATILE int oldsave = savestack->ary_fill;
  1245.     SPAT * VOLATILE oldspat = curspat;
  1246.     SPAT * VOLATILE oldlspat = lastspat;
  1247.     VOLATILE int sp = arglast[0];
  1248.  
  1249.     tmps_base = tmps_max;
  1250.     str_set(stab_val(stabent("@",TRUE)),"");
  1251.     in_eval++;
  1252.     if (++loop_ptr >= loop_max) {
  1253.     loop_max += 128;
  1254.     Renew(loop_stack, loop_max, struct loop);
  1255.     }
  1256.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1257.     loop_stack[loop_ptr].loop_sp = sp;
  1258. #ifdef DEBUGGING
  1259.     if (debug & 4) {
  1260.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1261.     }
  1262. #endif
  1263.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1264.     st = stack->ary_array;
  1265.     sp = arglast[0];
  1266.     if (gimme != G_ARRAY)
  1267.         st[++sp] = &str_undef;
  1268.     }
  1269.     else {
  1270.     sp = cmd_exec(cmd,gimme,sp);
  1271.     st = stack->ary_array;
  1272. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1273.         st[i] = str_mortal(st[i]);  not needed, I think */
  1274.                 /* if we don't save result, free zaps it */
  1275.     }
  1276.  
  1277.     in_eval--;
  1278. #ifdef DEBUGGING
  1279.     if (debug & 4) {
  1280.     char *tmps = loop_stack[loop_ptr].loop_label;
  1281.     deb("(Popping label #%d %s)\n",loop_ptr,
  1282.         tmps ? tmps : "" );
  1283.     }
  1284. #endif
  1285.     loop_ptr--;
  1286.     tmps_base = oldtmps_base;
  1287.     curspat = oldspat;
  1288.     lastspat = oldlspat;
  1289.     curcmd = oldcurcmd;
  1290.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1291.     restorelist(oldsave);
  1292.  
  1293.     return sp;
  1294. }
  1295.  
  1296. /* This routine handles any switches that can be given during run */
  1297.  
  1298. static char *
  1299. moreswitches(s)
  1300. char *s;
  1301. {
  1302.     int numlen;
  1303.  
  1304.     switch (*s) {
  1305.     case '0':
  1306.     nrschar = scanoct(s, 4, &numlen);
  1307.     nrs = nsavestr("\n",1);
  1308.     *nrs = nrschar;
  1309.     if (nrschar > 0377) {
  1310.         nrslen = 0;
  1311.         nrs = "";
  1312.     }
  1313.     else if (!nrschar && numlen >= 2) {
  1314.         nrslen = 2;
  1315.         nrs = "\n\n";
  1316.         nrschar = '\n';
  1317.     }
  1318.     return s + numlen;
  1319.     case 'a':
  1320.     minus_a = TRUE;
  1321.     s++;
  1322.     return s;
  1323.     case 'c':
  1324.     minus_c = TRUE;
  1325.     s++;
  1326.     return s;
  1327.     case 'd':
  1328. #ifdef TAINT
  1329.     if (euid != uid || egid != gid)
  1330.         fatal("No -d allowed in setuid scripts");
  1331. #endif
  1332.     perldb = TRUE;
  1333.     s++;
  1334.     return s;
  1335.     case 'D':
  1336. #ifdef DEBUGGING
  1337. #ifdef TAINT
  1338.     if (euid != uid || egid != gid)
  1339.         fatal("No -D allowed in setuid scripts");
  1340. #endif
  1341.     debug = atoi(s+1) | 32768;
  1342. #else
  1343.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1344. #endif
  1345.     /*SUPPRESS 530*/
  1346.     for (s++; isDIGIT(*s); s++) ;
  1347.     return s;
  1348.     case 'i':
  1349.     inplace = savestr(s+1);
  1350.     /*SUPPRESS 530*/
  1351.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1352.     *s = '\0';
  1353.     break;
  1354.     case 'I':
  1355. #ifdef TAINT
  1356.     if (euid != uid || egid != gid)
  1357.         fatal("No -I allowed in setuid scripts");
  1358. #endif
  1359.     if (*++s) {
  1360.         (void)apush(stab_array(incstab),str_make(s,0));
  1361.     }
  1362.     else
  1363.         fatal("No space allowed after -I");
  1364.     break;
  1365.     case 'l':
  1366.     minus_l = TRUE;
  1367.     s++;
  1368.     if (isDIGIT(*s)) {
  1369.         ors = savestr("\n");
  1370.         orslen = 1;
  1371.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1372.         s += numlen;
  1373.     }
  1374.     else {
  1375.         ors = nsavestr(nrs,nrslen);
  1376.         orslen = nrslen;
  1377.     }
  1378.     return s;
  1379.     case 'n':
  1380.     minus_n = TRUE;
  1381.     s++;
  1382.     return s;
  1383.     case 'p':
  1384.     minus_p = TRUE;
  1385.     s++;
  1386.     return s;
  1387.     case 'u':
  1388.     do_undump = TRUE;
  1389.     s++;
  1390.     return s;
  1391.     case 'U':
  1392.     unsafe = TRUE;
  1393.     s++;
  1394.     return s;
  1395.     case 'v':
  1396.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1397.     fputs(rcsid,stdout);
  1398.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1399. #ifdef macintosh
  1400.     fputs("MPW port Copyright (c) 1991, 1992 Matthias Neeracher & Tim Endres\n",
  1401.     stdout);
  1402. #endif    
  1403. #ifdef MSDOS
  1404.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1405.     stdout);
  1406. #ifdef OS2
  1407.         fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
  1408.         stdout);
  1409. #endif
  1410. #endif
  1411.     fputs("\n\
  1412. Perl may be copied only under the terms of either the Artistic License or the\n\
  1413. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1414. #ifdef MSDOS
  1415.         usage(origargv[0]);
  1416. #endif
  1417.     exit(0);
  1418.     case 'w':
  1419.     dowarn = TRUE;
  1420.     s++;
  1421.     return s;
  1422.     case ' ':
  1423.     case '\n':
  1424.     case '\t':
  1425.     break;
  1426.     default:
  1427.     fatal("Switch meaningless after -x: -%s",s);
  1428.     }
  1429.     return Nullch;
  1430. }
  1431.  
  1432. /* compliments of Tom Christiansen */
  1433.  
  1434. /* unexec() can be found in the Gnu emacs distribution */
  1435.  
  1436. my_unexec()
  1437. {
  1438. #ifdef UNEXEC
  1439.     int    status;
  1440.     extern int etext;
  1441.     static char dumpname[BUFSIZ];
  1442.     static char perlpath[256];
  1443.  
  1444.     sprintf (dumpname, "%s.perldump", origfilename);
  1445.     sprintf (perlpath, "%s/perl", BIN);
  1446.  
  1447.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1448.     if (status)
  1449.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1450.     exit(status);
  1451. #else
  1452. #ifdef MSDOS
  1453.     abort();    /* nothing else to do */
  1454. #else /* ! MSDOS */
  1455. #   ifndef SIGABRT
  1456. #    define SIGABRT SIGILL
  1457. #   endif
  1458. #   ifndef SIGILL
  1459. #    define SIGILL 6        /* blech */
  1460. #   endif
  1461.     kill(getpid(),SIGABRT);    /* for use with undump */
  1462. #endif /* ! MSDOS */
  1463. #endif
  1464. }
  1465.  
  1466.